home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / FLAGS.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  1KB  |  60 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2.  
  3. unit flags;
  4.  
  5. interface
  6.  
  7. uses gentypes,subs1;
  8.  
  9. const accessstr:array [accesstype] of string[8]=
  10.         ('By level','Keep out','Let in','');
  11.  
  12. procedure setuseraccflag (var u:userrec; bn:integer; ac:accesstype);
  13. function getuseraccflag (var u:userrec; bn:integer):accesstype;
  14. procedure setallflags (bn:integer; ac:accesstype);
  15. procedure setalluserflags (var u:userrec; ac:accesstype);
  16.  
  17. implementation
  18.  
  19. procedure setuseraccflag (var u:userrec; bn:integer; ac:accesstype);
  20. begin
  21.   if (ord(ac) and 1)=1
  22.     then u.access1:=u.access1+[bn]
  23.     else u.access1:=u.access1-[bn];
  24.   if (ord(ac) and 2)=2
  25.     then u.access2:=u.access2+[bn]
  26.     else u.access2:=u.access2-[bn]
  27. end;
  28.  
  29. function getuseraccflag (var u:userrec; bn:integer):accesstype;
  30. var ac:accesstype;
  31. begin
  32.   getuseraccflag:=accesstype(ord(bn in u.access1) or
  33.                              (ord(bn in u.access2) shl 1))
  34. end;
  35.  
  36. procedure setallflags (bn:integer; ac:accesstype);
  37. var cnt:integer;
  38.     u:userrec;
  39. begin
  40.   for cnt:=1 to filesize(ufile)-1 do begin
  41.     seek (ufile,cnt);
  42.     read (ufile,u);
  43.     setuseraccflag (u,bn,ac);
  44.     seek (ufile,cnt);
  45.     write (ufile,u)
  46.   end
  47. end;
  48.  
  49. procedure setalluserflags (var u:userrec; ac:accesstype);
  50. var b1,b2:byte;
  51. begin
  52.   b1:=(ord(ac) and 1)*255;
  53.   b2:=((ord(ac) and 2) shr 1)*255;
  54.   fillchar (u.access1,32,b1);
  55.   fillchar (u.access2,32,b2)
  56. end;
  57.  
  58. begin
  59. end.
  60.